#
# Monitor.pm : タイを使った変数の監視
#
#
package Monitor;
use Exporter;
@ISA = (Exporter);
@EXPORT_OK = ('monitor', 'unmonitor');

# 変数を監視する
sub monitor {
    my ($rvar, $name) = @_;
    my $type = ref( $rvar );     # 型のチェック
    if( $type eq 'SCALAR' ){
	tie $$rvar, 'MonScalar', $name, $$rvar;
    } elsif( $type eq 'ARRAY' ){
	tie @$rvar, 'MonArray', $name, $rvar;
    } elsif( $type eq 'HASH' ){
	tie %$rvar, 'MonHash', $name, $rvar;
    } else {
	print STDERR "リファレンスが必要です\n";
    }
}

# 変数の監視を止める
sub unmonitor {
    my $rvar = shift;
    my $type = ref( $rvar );     # 型のチェック
    if( $type eq 'SCALAR' ){
	MonScalar->unmonitor( $rvar );
    } elsif( $type eq 'ARRAY' ){
	MonArray->unmonitor( $rvar );
    } elsif( $type eq 'HASH' ){
	MonHash->unmonitor( $rvar );
    } else {
	print STDERR "リファレンスが必要です\n";
    }
}

# スカラーの監視
package MonScalar;

sub TIESCALAR {
    my ($pkg, $name, $value) = @_;
    my $obj = { name => $name, value => $value };
    bless $obj, $pkg;
    $obj;
}

sub FETCH {
    my $obj = shift;
    print 'Read : $', $obj->{'name'}, " -> $obj->{'value'}\n";
    $obj->{'value'};
}

sub STORE {
    my ($obj, $new_value) = @_;
    print 'Write : $', $obj->{'name'}," <- $new_value\n";
    $obj->{'value'} = $new_value;
}

sub DESTROY {
    my $obj = shift;
    if( $obj->{'name'} ne '__UNMONITOR__' ){
	print 'DESTORY $', "$obj->{'name'}\n";
    }
}


sub unmonitor {
    my ($pkg, $rvar) = @_;
    my $last_value;
    {
	my $obj = tied $$rvar;
	$last_value = $obj->{'value'};
	$obj->{'name'} = '__UNMONITOR__'
    }
    untie $$rvar;
    $$rvar = $last_value;
}


# 配列の監視
package MonArray;

sub TIEARRAY {
    my ($pkg, $name, $ra) = @_;
    my $obj = {
	name => $name, array => [@$ra],
    };
    bless $obj, $pkg;
    $obj;
}

sub FETCH {
    my ($obj, $index) = @_;
    my $value = $obj->{'array'}->[$index];
    print 'Read : $',$obj->{'name'}, "[$index] -> $value\n";
    $value;
}

sub STORE {
    my ($obj, $index, $new_value) = @_;
    print 'Write : $',$obj->{'name'}, "[$index] <- $new_value\n";
    $obj->{'array'}->[$index] = $new_value;
}

sub DESTROY {
    my $obj = shift;
    if( $obj->{'name'} ne '__UNMONITOR__' ){
	print 'DESTORY @', "$obj->{'name'}\n";
    }
}

sub unmonitor {
    my ($pkg, $rvar) = @_;
    my $last_array;
    {
	my $obj = tied @$rvar;
	$last_array = $obj->{'array'};
	$obj->{'name'} = '__UNMONITOR__'
    }
    untie @$rvar;
    @$rvar = @$last_array;
}


# ハッシュの監視
package MonHash;

sub TIEHASH {
    my ($pkg, $name, $rh) = @_;
    my $obj = {
	name => $name, hash => {%$rh},
    };
    bless $obj, $pkg;
    $obj;
}

sub FETCH {
    my ($obj, $index) = @_;
    my $value = $obj->{'hash'}->{$index};
    print 'Read : $', $obj->{'name'}, "{$index} -> $value\n";
    $value;
}

sub STORE {
    my ($obj, $index, $new_value) = @_;
    print 'Write : $', $obj->{'name'}, "{$index} <- $new_value\n";
    $obj->{'hash'}->{$index} = $new_value;
}

sub CLEAR {
    my $obj = shift;
    print 'Clear : %', "$obj->{'name'}\n";
    $obj->{'hash'} = {};
}

sub DESTROY {
    my $obj = shift;
    if( $obj->{'name'} ne '__UNMONITOR__' ){
	print 'DESTORY %', "$obj->{'name'}\n";
    }
}

sub unmonitor {
    my ($pkg, $rvar) = @_;
    my $last_hash;
    {
	my $obj = tied %$rvar;
	$last_hash = $obj->{'hash'};
	$obj->{'name'} = '__UNMONITOR__'
    }
    untie %$rvar;
    %$rvar = %$last_hash;
}


1;
    
# end of file
    
